home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / icon / contrib / treefox.lha / FOX.ICN < prev    next >
Encoding:
Text File  |  1993-04-24  |  34.5 KB  |  1,190 lines
  1. # FOX (ENGLISH)
  2. global indx, bstack, out, lex, anfpos, st, current, previous, pending,
  3.        Lines, max, inter, verbose, steps, normattr
  4.  
  5. procedure main(opt)
  6.   if not(&features=="MS-DOS extensions") then {
  7.     writes("\nThis program requires a non-386 DOS ICON. ")
  8.     getch(); stop()
  9.   }
  10.   verbose := 0  ## don't write debugs
  11.   steps := 2    ## 0 no steps, 1 stepwise, 2 stepwise auto
  12.   srows := 25
  13.   bstack := [];
  14.   #if *opt=0 then max:=10 else max := opt[1]+1;
  15.   max := 11
  16.   normattr := 7
  17.   if *opt>0 then normattr := numeric(opt[1]);
  18.   clrscr(normattr)
  19.   out := open("fox.tmp", "w")
  20.  
  21.   indx := create seq(1,1)
  22.  
  23.   lex := table()
  24.  
  25.   if inp:=open("fox-lex") then {
  26.     write("Integrating fox-lex")
  27.     while st := trim(read(inp)) do {
  28.       if match("#",st) | (st=="") then next
  29.       st ? if word := tab(find("  ")) then {
  30.         tab(many(' '))
  31.         lex[word] := trim(tab(0))
  32.       }
  33.       while st[-1]==";" do {
  34.         (st := trim(read(inp))) | break
  35.         lex[word] ||:= st[upto(~' ',st):0]
  36.       }
  37.     }
  38.     close(inp)
  39.   } else {
  40.     write("Not found: fox-lex"); getch()
  41.   }
  42.   inp := &null
  43.   repeat {
  44.     clrscr(normattr)
  45.     qwrite(1,2,"FOX - A FRAME ORIENTED X-BAR PARSER",normattr)
  46.     qwrite(1,3,"M. Jahn (1993)",normattr)
  47.     qwrite(1,5,"ESC:quit  ENTER:list corpus  SPACE:interactive mode  s:SYSVARS",normattr)
  48.     gotoXY(65,5)
  49.     st := getch()
  50.     write()
  51.     if st==("q"|"\e") then break
  52.     if st==char(13) then {
  53.       if normattr=240 then system("SCROLLER.EXE fox.in 192,206,240,48,112") else
  54.         system("SCROLLER.EXE fox.in")
  55.       inp:=open("SCROLLER.DSK")
  56.       (st := read(inp)) | stop("nothing in SCROLLER.DSK")
  57.       if match("exit",st) then stop()
  58.       close(inp); inp := &null
  59.     } else
  60.     if st=="s" then {
  61.       repeat {
  62.         writes("SYSVARS settings:  v:verbose  m:max  s:steps  ENTER:continue")
  63.         writes("(",verbose,", ",max,", ", steps,") ")
  64.         st := getch()
  65.         case st of {
  66.           "s": { steps+:=1
  67.                  if steps>=3 then steps:=0; write() }
  68.           "v": { if verbose=0 then verbose:=1 else verbose:=0; write() }
  69.           "m": { writes("\nMax= "); max:=numeric(read())
  70.                  if (max>11) then {
  71.                    if srows=25 then {
  72.                      srows:=43; system("mode 80,43")
  73.                      clrscr(normattr)
  74.                    }
  75.                  } else if srows=43 then {
  76.                    srows:=25; system("mode 80,25")
  77.                    clrscr(normattr)
  78.                  }
  79.                }
  80.           default: break
  81.         }
  82.       }
  83.       next
  84.     } else st := ""
  85.     indx := ^indx
  86.     (st := "xxx,"||lookup(st)) | next
  87.     clrscr(normattr);
  88.     showtree(st,"Given:")
  89.     while st := build()
  90.     if steps=0 then showtree(st,"")
  91.     qwrite(1,2*max+2,"ENTER to continue ",normattr)
  92.     gotoXY(18,2*max+2)
  93.     until getch()==char(13)
  94.     #write("\n\n\n")
  95.   }
  96.   write("\n\nFOX stopped. Protocol file is fox.tmp.")
  97.   if max>11 then system("mode 80,25")
  98. end #main
  99.  
  100. procedure writ(L[])
  101.   if verbose=0 then fail
  102.   if not numeric(L[1]) then {
  103.     every writes(!L)
  104.     every writes(out,!L)
  105.   } else {
  106.     every writes(!L[2:0])
  107.     every writes(out,!L[2:0])
  108.   }
  109.   writes("\n",out,"\n")
  110.   if numeric(L[1]) then if getch()==("q"|"\e") then {
  111.     stop()
  112.   }
  113. end
  114.  
  115. procedure Auxadjust(st1)
  116. local word
  117. ## adjust wrong I-attrib for "who did she/are you ..."
  118.   matrix := "(IP,?NP,(Ibar,?I,?VP)),(VP,(Vbar,(V,1),?NP?AP)),"
  119.   #writ(1,"auxadjust:")
  120.   st1 ? if (tab(anfpos<-bal(',')+1) & tab(match("(I,"))) then {
  121.     word := tab(upto(')'))
  122.     move(2)
  123.     #writ("anf,word=",anfpos,word)
  124.  
  125.     if word == ("did"|"does"|"do"|  "am"|"are"|"is"|"was"|"were") &
  126.       (not find("(VP,",st1)) then {
  127.       current := "(I,+t),"
  128.       matrix := xchg(matrix,"1",word)
  129.       if anfpos = 5 then    ## was he a boy
  130.         st1 := st[1:anfpos] || current || tab(bal(',')+1) || matrix || tab(0)
  131.       else  ## who did it
  132.         st1 := st1[1:anfpos] || current || matrix || tab(0)
  133.      # writ(1,"st1=", st1)
  134.       showtree(st1,"I adjusted to full vb.")
  135.       return st1
  136.     }
  137.   }
  138. end
  139.  
  140.  
  141. procedure build()
  142.   st := trim(st,',') || ","
  143.   pending := ""
  144.   previous:= "***"
  145.   writ("BUILD:")
  146.   st ? while anfpos:=&pos do {
  147.     current := tab(bal(','))
  148.     move(1) | break
  149.     writ("current=",current)
  150.     writ("pending=",pending)
  151.  
  152.       ## check ambiguous headcat
  153.     w := (current[2:upto(',',current)] | "")
  154.     if find("/",w) then {
  155.       writ("multiple main categories.")
  156.       if newcurrent := handlevariants(anfpos,current,st) then {
  157.         newcurrent := expandentry(current)
  158.         writ("st=anfpos=",st,anfpos)
  159.         st := st[1:anfpos] || newcurrent || tab(0)
  160.         &subject := st
  161.         &pos := 1
  162.         writ("st=",st)
  163.         showtree(st,"Built: category.select:")
  164.         next
  165.       }
  166.     }
  167.  
  168.     cat := "***"
  169.     cat := current[2:upto(',',current)]
  170.     if p := proc("handle_"||cat,1) then {
  171.        writ("calling handle_",cat)
  172.        if anfpos := p(current) then {
  173.          writ("pending=",pending)
  174.          &subject := st; &pos := anfpos
  175.          writ("anfpos/st=",anfpos,st)
  176.          next
  177.        }
  178.     }
  179.     previous := current
  180.   }
  181.  
  182.   ## level 2 handling:
  183.   st1 := st
  184.   grab("AP,NP,NSp,Nbar,Vbar,Ibar,PP,VP,")
  185.   st := Auxadjust(st)
  186.   if st ~== st1 then return st
  187.   grab("")
  188.   if st := procontrol(st) then {
  189.     grab("IP,CP,")
  190.     return st
  191.   }
  192.   st1 := st
  193.   while st := traced(st) do grab("CP,IP,VP,")
  194.   if st ~== st1 then return st
  195.   if st := cleanout(st) then {
  196.     showtree(st,"  ")
  197.     if grab("")=1 then fail
  198.   }
  199.   write(out,st,"\n\n")
  200.   if *bstack > 0 then {
  201.     st := pop(bstack)
  202.     writ("popped from bstack=", st)
  203.     showtree(st,"Resetting to unexplored variant")
  204.     indx:=^indx
  205.     return st
  206.   }
  207. end # build
  208.  
  209. procedure cleanout(st)
  210.   st1 := ""
  211.   st ? {
  212.     while st1 ||:= tab(find(",%")) do {
  213.       move(2)
  214.       tab(upto(',?)'))
  215.     }
  216.     if st[&pos]=="?" then st1 ||:= ","
  217.     st1 ||:= tab(0)
  218.   }
  219.   return st1
  220. end
  221.  
  222.  
  223. procedure expandentry(current)
  224. local i, entry, word, entrybit
  225.   current ? if tab(find(",")+1) then word:=tab(-1)
  226.   writ("word=",word)
  227.   (entry := \lex[word]) | stop("no lex entry for "|| word)
  228.   if find(";",entry) then {
  229.      i := 0
  230.      entry||";" ? while entry1 := tab(upto(';')+1) do {
  231.        entrybit := ""
  232.        i +:= 1
  233.        entry1 ? if match(current[2]) then {
  234.          entrybit := tab(-1)
  235.          if find("(",entrybit) then entrybit := entrybit[3:0]
  236.          word ||:= string(i)
  237.          lex[word]:=entrybit
  238.          writ("entrybit=", entrybit)
  239.          return lookup(word)
  240.        }
  241.      }
  242.    }
  243. end
  244.  
  245. procedure handlevariants(anfpos,current, st)
  246. local i, j, w, newcurrent
  247.   current ? if tab(find("/")) then {
  248.     i := &pos
  249.     w := ""
  250.     while (&pos>1) & (&pos-:=1) do {
  251.       if match(","|"(") then {
  252.         j := &pos
  253.         tab(i+1)
  254.         w := tab(upto(',)'))
  255.         if *w>0 then {
  256.           newcurrent := current[1:j+1] || current[i+1:0]
  257.           writ("pushing=", newcurrent)
  258.           push(bstack, st[1:anfpos]||newcurrent||st[anfpos+*current:0])
  259.         }
  260.         newcurrent := current[1:i] || tab(0)
  261.         writ("newcurrent=", newcurrent)
  262.         return newcurrent
  263.       }
  264.     }
  265.   }
  266. end
  267.  
  268.  
  269. procedure handle_CSp(current)
  270.   pending := "(CP,?CSp,(Cbar,C,?IP))"
  271.   previous := current
  272.   return anfpos + *current + 1
  273. end
  274.  
  275. procedure handle_C(current)
  276.   if (*pending=0) then pending := "(CP,CSp,(Cbar,C,?IP))"
  277.   if find("C,",pending) then {
  278.     current := xchg(pending,"C,",current||",")
  279.     st := st[1:anfpos] || current || "," || tab(0)
  280.     writ(1,"st=", st)
  281.     showtree(st,"Built:"||current)
  282.     pending := ""
  283.     previous := current
  284.     return anfpos + *current + 1
  285.   }
  286. end
  287.  
  288. procedure handle_I(current)
  289.   writ("previous=",previous)
  290.   if find("(wh,",previous) & not(find("?",current)) &
  291.   not(match("(N")) then {
  292.     ## grab-protect this I
  293.     current := "(I,??" || current[4:0]
  294.     st := st[1:anfpos] || current || ","  || tab(0)
  295.     writ(1,"st=", st)
  296.     showtree(st,"Built:I grab-protected")
  297.     previous := current
  298.     return anfpos + *current + 1
  299.   }
  300. end
  301.  
  302. procedure handle_IP(current)
  303.   if match("(CP,", pending) then {
  304.     st := st[1:anfpos] || pending || "," || st[anfpos:0]
  305.     pending := ""
  306.     return anfpos + *pending + 1
  307.   }
  308.   if i:=find("?I,",current) & (not ((find("(I,",st)|*st) < &pos)) then {
  309.     current := current[1:i] || "(I,+t1)"  || current[i+2:0]
  310.     st := st[1:anfpos] || current || "," || tab(0)
  311.     showtree(st,"Built: I,+t1")
  312.     previous := current
  313.     return anfpos + *current + 1
  314.   }
  315. end
  316.  
  317. procedure handle_NP(current)
  318. local nbar
  319.   if not match("(VP,",pending) then {
  320.     if match("(NP",pending) then {
  321.       nbar := ""
  322.       current ? if tab(find("(Nbar")) then {
  323.         nbar := tab(bal(')'))
  324.         writ(1,"nbar=",nbar)
  325.       }
  326.       if *nbar > 0 then {
  327.         current := xchg(pending,"(Nbar,?N)",nbar)
  328.         st := st[1:anfpos] || current || "," || tab(0)
  329.       }
  330.     }
  331.     pending := ""
  332.     previous := current
  333.     return anfpos + *current + 1
  334.   }
  335. end
  336.  
  337. procedure handle_NSp(current)
  338.   if *pending=0 then {
  339.     pending := "(NP,?NSp,(Nbar,?N))"
  340.     previous := current
  341.     return anfpos + *current + 1
  342.   } else
  343.   if find("?NSp", pending) then {
  344.     # (the >book's) covers...
  345.     newcurrent := xchg(current,"NSp","N") # sex change
  346.     pending := xchg(pending,"?N)",newcurrent||")")
  347.     st := st[1:anfpos] || "(NSp," || pending || ")," || tab(0)
  348.     pending := ""
  349.     return anfpos
  350.   } else fail
  351. end
  352.  
  353. procedure handle_N(current)
  354.   if match("(VP",pending) then fail
  355.   if (*pending=0) then pending :="(NP,(Nbar,?N))"
  356.   if match("(NP,",pending) then {
  357.     current := xchg(pending,"?N)",current||")")
  358.     st := st[1:anfpos] || current || "," || tab(0)
  359.     writ(1,"st=", st)
  360.     showtree(st,"Built:"||current)
  361.     pending := ""
  362.     previous := current
  363.     return anfpos + *current + 1
  364.   }
  365. end
  366.  
  367. procedure handle_AP(current)
  368. local i, newbar
  369. static oldbar
  370. initial oldbar := "(Nbar,?N)"
  371.   if pending=="" then pending := "(NP,(Nbar,?N))"
  372.   newbar := "(Nbar,?AP,(Nbar,?N))"
  373.   if match("(Adv",previous) then
  374.     current := "(AP,(Abar,?Adv," || current[5:0] || ")"
  375.   if i := find(oldbar,pending) then {
  376.     pending := pending[1:i] || newbar || pending[i+*oldbar:0]
  377.     st := st[1:anfpos] || current || ","  || tab(0)
  378.     previous := ""
  379.     return anfpos + *current + 1
  380.   }
  381. end
  382.  
  383. procedure handle_PP(current)
  384.   if find("(wh,",current) then {
  385.     pending := "(VP,(Vbar,1,?PP))"
  386.     previous := current
  387.     return anfpos + *current + 1
  388.   }
  389. end
  390.  
  391. procedure handle_VP(current)
  392. local i
  393.   if match("(VP",pending) & (not find("?PP",current)) then {
  394.     ## skip if ?PP already in current
  395.     i := find("(Vbar",current)
  396.     pending := current[1:i] || pending[5:0]
  397.     current := xchg(pending,"1",current[i:-1])
  398.     writ("new current=",current)
  399.     st := st[1:anfpos] || current || "," || tab(0)
  400.     writ(1,"st=", st)
  401.     showtree(st,"PP-adjunct to VP")
  402.     previous := current
  403.     pending := ""
  404.     return anfpos + *current + 1
  405.   }
  406. end
  407.  
  408. procedure lookup_getst(st0)
  409. local i, a, word, st1
  410.   if /st0 | (st0=="") then {
  411.     write("current lexicon:")
  412.     a := sort(lex,1)
  413.     every i:=1 to *a do writes(a[i][1],"  ")
  414.     write("\n\nENTER A SENTENCE:")
  415.     st0 := read()
  416.   }
  417.   st1 := ""
  418.   st0 ? {
  419.     while a := tab(upto('(')) do {
  420.       st1 ||:= map(a,",.;:?!-","       ")
  421.       st1 ||:= (tab(bal(' ')) | tab(0))
  422.     }
  423.     st1 ||:= map(tab(0),",.;:?!-","       ")
  424.   }
  425.   st1 := xchg(st1,"  "," ")
  426.   if st1=="" then stop()
  427.   word := st1[1:find(" ",st1)|0]
  428.   if /lex[word] then {
  429.     a := ord(word[1])
  430.     if (65<=a) & (a<=90) then st1[1] := char(a+32)
  431.   }
  432.   return st1
  433. end
  434.  
  435. procedure lookup_lex(word)
  436. local entry, dummy, root
  437.   if word=="" then return""
  438.   entry := ""
  439.   if /lex[word] then {
  440.     if (word[1]=="(") | (word[-2:0]==("'s"|"s'"|"ly")) then fail
  441.     write("NO LEX ENTRY FOR ",word)
  442.     writes("   CATEGORIZE [A,Adv,N,NPwh,NSp,NSpwh,P,PPwh,V ?NP_?NP]:  ")
  443.     dummy := read()
  444.     if *dummy>0 then entry := lex[word] := dummy
  445.     if entry[1]=="+" then {
  446.       root := entry[find(" ",entry)+1:0]
  447.       if /lex[root] then {
  448.         write("NO LEX ENTRY FOR ",root)
  449.         writes("   CATEGORIZE:   ")
  450.         dummy := read()
  451.         if *dummy > 0 then lex[root] := dummy
  452.         if \lex[dummy] then {
  453.           lex[root] := lex[dummy]
  454.           write("   CATEGORIZED LIKE ", dummy)
  455.         }
  456.       }
  457.     }
  458.     if \lex[entry] then {
  459.       write("   CATEGORIZED LIKE ", entry)
  460.       lex[word] := lex[entry]
  461.       return lex[word]
  462.     }
  463.   }
  464.   return lex[word]
  465. end #lookup_lex
  466.  
  467. procedure lookup(st0)
  468. local entry, options, word, st1, vpat, compl, vsp, affix, matrix, verbmatrix,i
  469.   vpat := verbmatrix := "(IP,1,(Ibar,?I,?VP)),(VP,(Vbar,(V,_),2))"
  470.   compl := ""; matrix := ""; affix := "";  vsp := ""; entry := ""
  471.   st0 := lookup_getst(st0) || " "
  472.   writ("LOOKING UP: ", st0)
  473.   pending := ""
  474.   st1 := ""
  475.  
  476.   st0 ? while (i:=&pos) & (word := tab(many(~' '))) do {
  477.     if word[1] == "(" then {
  478.       &pos := i
  479.       st1 ||:= tab(bal(' ')) || ","
  480.       writ("i,word=",i,word)
  481.       writ("st1=",st1)
  482.       tab(many(' '))
  483.       next
  484.     }
  485.     if word[-2:0]==("'s"|"s'") then entry := "NSp" else
  486.     if (word[-2:0]=="ly") & (not lookup_lex(word)) then
  487.       entry := "Adv"
  488.  
  489.     tab(many(' '))
  490.     i := &pos
  491.     writ("i/word=", i, word)
  492.     writ("st1=",st1)
  493.  
  494.     if find(word||",","am,are,be,been,do,does,to,did,is,was,were,have,had,has,") then {
  495.       if (st1=="") | (find("(wh",st1) & (not find("(I,",st1))) then {
  496.         #if word==("do"|"does"|"did"|"to"|"have"|"had"|"has") then {
  497.           st1 ||:= "(I," || word || "),"; next
  498.         #}
  499.       }
  500.       nextword := (tab(many(~' ')) | "")
  501.       writ("nextw (auxblock)=",nextword)
  502.  
  503.       ## DO + TO
  504.       if word==("do"|"does"|"did"|"to") then {
  505.         if lookup_lex(nextword)[1]=="V" then {
  506.           if (word=="to" | not find("(I,",st1)) then
  507.             matrix := "(I," || word || "),"
  508.           word := nextword; tab(many(' '))
  509.         } else &pos := i  ## push nextword; word = fullvb
  510.  
  511.       ## HAVE, HAS, HAD  + pt2
  512.       } else if word==("have"|"has"|"had") then {
  513.         if nextword ~== "been" then {
  514.           if find("+pt2",lookup_lex(nextword)) then {
  515.             if not find("(I,",st1) then matrix := "(I," || word || ")," else
  516.               vsp := "(VSp," || word || "),"
  517.             word := nextword; tab(many(' '))
  518.             entry := xchg(lookup_lex(word),"+t2","")
  519.               # del t2-reference; set entry
  520.           } else &pos := i
  521.  
  522.         ## HAVE + BEEN + -ing/-en
  523.         } else if nextword=="been" then {
  524.           move(1); nextword := (tab(many(~' ')) | "")
  525.           if find("+pt",\lex[nextword]) then {
  526.             if not find("(I,",st1) then {
  527.               matrix := "(I," || word || "),"
  528.               vsp := "(VSp,been),"
  529.             } else vsp := "(VSp," || word || ",been),"
  530.             if find("+pt2",\lex[nextword]) then  ##passive
  531.               verbmatrix := xchg(verbmatrix,"1","?ISp")
  532.             word := nextword; tab(many(' '))
  533.             entry := xchg(lookup_lex(word),"+t2","")  # kill t2 func of -ed
  534.             entry := xchg(entry,"+a","")  # kill adj func of -ing
  535.           } else {  ## fullverb: have been boys/eager
  536.             if not find("(I,",st1) then matrix := "(I," || word || "),"  else
  537.               vsp := "(VSp," || word || "),"
  538.             &pos := i + 5     ## i + *"been" + 1
  539.             word := "been"
  540.           }
  541.         }
  542.  
  543.       ## BE
  544.       } else if word == ("am"|"are"|"was"|"were"|"is"|"be"|"been") then {
  545.         if find("+pt",\lex[nextword]) then {  ##passive or progr.
  546.           vsp := "(VSp," || word || "),"
  547.           if find("+pt2",\lex[nextword]) then  ##passive
  548.             verbmatrix := xchg(verbmatrix,"1","?ISp")
  549.           writ(1,"vsp=",vsp)
  550.           word := nextword
  551.           entry := xchg(lookup_lex(word),"+t2","")
  552.           entry := xchg(entry,"+a","")
  553.           tab(many(' '))
  554.         } else &pos := i
  555.       }
  556.     }
  557.  
  558.     writ("word=",word)
  559.     writ("pending=",pending)
  560.     writ("entry=",entry)
  561.  
  562.     if *entry=0 then entry := lookup_lex(word)
  563.     if /entry | (entry=="") then fail
  564.     if not find(";",entry) then {
  565.       if find("+a",entry) then entry := "A" # set +pt1 to A
  566.       else if entry[1]=="+" then {
  567.         if i:=find("+t",entry) then
  568.           matrix := "(I,+t" || entry[i+2] || ")," else
  569.         if i := find("+pt"||("1"|"2"),entry) then
  570.           affix := "(" || entry[i+:4] || ",_)"
  571.  
  572.         if find("+pt2",entry) & ((*vsp>0 & not find("ha",vsp)) |
  573.           find("(I,"|| ("am"|"are"|"is"|"was"|"were"),st1)) then
  574.             verbmatrix := xchg(verbmatrix,"1","?ISp") else
  575.         if find("+pt1",entry) then {
  576.           if (*matrix=0) & (*vsp=0) then matrix := "(I,-t),"
  577.         }
  578.         root := entry[find(" ",entry)+1:0]
  579.         entry := lookup_lex(root)
  580.       }
  581.       if entry=="" then fail
  582.       if entry=="A" then entry := "(AP,(Abar,(A,_)))" else
  583.       if entry=="P" then entry := "(PP,(Pbar,(P,_),?NP))" else
  584.       if find("wh",entry) then
  585.         entry := "(" || entry[1:find("wh",entry)] || ",(wh,_))"
  586.       if find("_"|"(",entry) then {
  587.         if match("A _",entry) then
  588.           entry := xchg("(AP,(Abar,(A,_),2))","2",entry[4:0]) else
  589.         if match("N _",entry) then {
  590.           entry := xchg("(NP,(Nbar,(N,_),2))","2",entry[4:0])
  591.         } else if match("P _",entry) then {
  592.           entry := xchg("(PP,(Pbar,(P,_),2))","2",entry[4:0])
  593.         } else if match("V ",entry) then {
  594.           entry ? if move(2) then {
  595.             matrix||:=xchg(verbmatrix,"1",tab(upto('_')))
  596.             writ("newmatrix=",matrix)
  597.             move(1)
  598.             compl := ","
  599.             compl ||:= tab(0)
  600.             if *compl=1 then compl := ""
  601.             entry := xchg(matrix,",2",compl)
  602.             if *vsp>0 then entry := xchg(entry,"(VP,","(VP," || vsp)
  603.             writ("entry_c=",entry)
  604.             if *affix>0 then entry := xchg(entry,"_",affix)
  605.             vsp := ""; affix := ""; matrix := ""; compl := ""
  606.             verbmatrix := vpat
  607.           }
  608.         }
  609.         entry := xchg(entry,"_",word)
  610.         if *pending>0 then {
  611.           entry := xchg(pending,"?3",entry)
  612.           pending:=""
  613.         }
  614.          ## get prep complement
  615.         entry ? { vsp:=tab(upto('?')+1) & (compl:=tab(many(&lcase))) &
  616.           (affix:=tab(0)) }
  617.         if *compl>0 then {
  618.           nextword := (tab(many(~' ')) | "")
  619.           if nextword==compl then {
  620.             pending := vsp || "3" || affix
  621.             entry := ""; vsp := ""; affix := ""
  622.             &pos := i
  623.             next
  624.           } else {
  625.             entry := xchg(entry,",?"||compl,"")
  626.             entry := xchg(entry,",,",",")
  627.           }
  628.           &pos := i
  629.         }
  630.         vsp := ""; affix := ""; compl:=""
  631.  
  632.         writ(1,"new entry=", entry)
  633.         st1 ||:=  entry || ","
  634.       } else st1 ||:="(" || entry || "," || word  || "),"
  635.     } else {
  636.        options := ""
  637.        entry||";" ? while entry1 := tab(upto(';')+1) do {
  638.          entry1 ? {
  639.            options ||:= (tab(upto(' ')) | tab(-1)) || "/"
  640.          }
  641.        }
  642.        st1 ||:="(" || options || "," || word  || "),"
  643.     }
  644.     entry:=""
  645.   }
  646.   writ(1,"looked up:",st1)
  647.   return st1
  648. end # lookup
  649.  
  650.  
  651. procedure procontrol(st)
  652.   ## NB mark CP/IP complement ?IP1 ?IP2 ?CP1 ?CP2 for subject/object
  653.   ## replace an unfillable (IP,?NP by PRO#n, coindexed with a preceding NP
  654. local i, i1, i2, j, current, prevIP, prevVP, nptype, previous
  655.   if not (find("CP1"|"CP2", st)) then fail
  656.   st := trim(st,',') || ","
  657.   current := prevVP := prevIP := ""
  658.   writ(1,"PROCONTROL:")
  659.   st ? while (previous:=current) & (i:=&pos) do {
  660.     current := tab(bal(','))
  661.     move(1) | fail
  662.     writ("current=",i,current)
  663.       ## save previously NP-saturated IP
  664.     if match("(IP,(NP,",current) then { i1:=i; prevIP := current}
  665.     if (k := find("%CP"|"?CP",current)+3) then {
  666.       if numeric(current[k]) then nptype:=current[k] else next
  667.       j := k+i+1
  668.       i2 := i
  669.       prevVP := current
  670.       writ("prevIP=",prevIP)
  671.       writ("type=",nptype)
  672.       next
  673.     }
  674.       ## check unsaturated NP in IP
  675.     (match("(IP,?NP,",current) & (*prevIP>0) & find("(I,to)",current)) | next
  676.     writ("prevIP=",prevIP)
  677.     writ(1,"type=",nptype)
  678.     if match("(CP",previous) then insert := "" else
  679.       insert:="(CP,CSp,(Cbar,C,?IP)),"       ## wondered whether/if/how
  680.     if numeric(nptype) & nptype<3 then {
  681.       n := "#" || @indx
  682.       if nptype == "1" then st := st[1:i1] || "(IP,(NP" || n ||
  683.          st[i1+7:i] || insert || "(IP,PRO" || n || st[i+7:0] else
  684.       if nptype == "2"  & *prevVP>0 then  {
  685.         newVP := xchg(prevVP,"(NP","(NP"||n)
  686.         if prevVP==newVP then fail
  687.         st := st[1:i2] || newVP || st[i2+*prevVP:i] || insert ||
  688.           "(IP,PRO" || n || st[i+7:0]
  689.       }
  690.       st[j]:=""  ## delete mark 1 or 2
  691.       writ(1,"st=", st)
  692.       showtree(st,"Procontrol: "||n)
  693.       return st
  694.     }
  695.   }
  696. end #procontrol
  697.  
  698. procedure traced(st)
  699. local i, cat, current, newcurrent, pc
  700.   st := trim(st,',') || ","
  701.   pc := 0
  702.   writ(1,"TRACED:")
  703.     ## sequence: I, wh-NP, Operator, NP(passive,raising)
  704.     #  what/which book ... NP
  705.     #  PP= where/how/why
  706.     #  CP= ? (Operator)
  707.     #  NP = seems/passive
  708.   st ? if (tab(i<-bal(',')+1) & cat<-tab(match("(I,"))) |
  709.           (tab(i<-bal(',')+1) & cat<-tab(match("(NP,(wh"|"(NP,(NSp,(wh"))) |
  710.           (tab(i<-bal(',')+1) & cat<-tab(match("(PP,("))) |
  711.           (tab(i<-bal(',')+1) & cat<-tab(match("(CP,CSp,("))) |
  712.           (tab(i<-bal(',')+1) & cat<-tab(match("(NP"))) then {
  713.     &pos := i
  714.     cat[1]:=""
  715.     current := tab(bal(','))
  716.     writ("current=",current)
  717.     if cat=="I," then newcurrent := "(C," else
  718.     if match("CP",cat) then {
  719.       newcurrent:="CP"
  720.       cat := "NP"
  721.     } else
  722.     if *cat>3 then {   ##PP or NPwh
  723.       cat := cat[1:3]
  724.       newcurrent :="(CSp,"
  725.     } else if cat=="NP" then {
  726.         if (find("?ISp")>i) then newcurrent := "(ISp,"  else fail
  727.     }
  728.  
  729.     every pc:=find(("?"|"%")||cat) do tab(pc)
  730.     if pc > 0 then {
  731.        pd := upto(',)')
  732.        until st[pc]==(","|"(") do pc-:=1
  733.        pc +:= 1
  734.         ## return to build CP before NP/ISp
  735.       #if ((newcurrent=="(ISp,") & (find(",(CSp",st)<pc)) then fail
  736.       writ("distant cat=", cat)
  737.     }
  738.   }  ## scanning finished
  739.   if pc > 0 then {
  740.     n := "#" || @indx
  741.       ## replace trace by index
  742.     if cat=="I," then cat :="I"
  743.     st := st[1:pc] || "(" || cat || "," || n || ")" || st[pd:0]
  744.     writ("st/1=",st)
  745.     W := st[i+*current:pc]
  746.     Z := st[pc:0]
  747.     writ("W=",W)
  748.     writ("Z=",Z)
  749.     if cat=="NP" then
  750.       W := xchg(W,  ",CSp,",  ",CSp"||n||",")
  751.       #st:=st[1:i]||xchg(st[i:pc],  ",CSp,",  ",CSp"||n||",") || st[pc:0]   # chain traces
  752.     writ("st/2=",st)
  753.     if newcurrent == "CP" then
  754.       newcurrent := xchg(current,"CSp","(CSp,O"||n||")") else
  755.     newcurrent ||:= "(" || cat || n || current[find(",",current):0] || ")"
  756.       ## abandon previous grab-protection
  757.     newcurrent := xchg(newcurrent,"??","")
  758.     writ("newcurrent=",newcurrent)
  759.     writ("current=   ",current)
  760.     #pd := *newcurrent - *current
  761.     #st := st[1:i] || newcurrent || st[i+*current+pd:0]
  762.     st := st[1:i] || newcurrent || W || Z
  763.     writ(1,"st/3=",st)
  764.     showtree(st,"Traced: "||n)
  765.     return st
  766.   }
  767. end #traced
  768.  
  769. procedure grab_headpos(current)
  770.   headpos := 0
  771.   head := current[2]
  772.   if head=="w" then head := "N"
  773.   current ? {
  774.     if ="(NP,(NSp" then {
  775.       move(-5)
  776.       tab(bal(')'))  ## skip NSp
  777.     }
  778.     headpos := find(("?"|"(")||head||(","|")"))+2
  779.   }
  780.   if headpos=0 then
  781.     every headpos := find(head||"bar",current)
  782.   writ("headpos=",headpos)
  783.   if headpos > 0 then return headpos
  784. end
  785.  
  786. procedure grableft(opt,headpos,current,previous)
  787. local cat, pc
  788.   writ("grabbing left")
  789.   if find("?"|opt,previous) then {
  790.     writ("left is blocked"); fail
  791.   }
  792.   current ? if move(headpos) then {
  793.     while move(-1) do {
  794.       if any ('?'++opt) then {
  795.         pc := &pos
  796.         move(1)
  797.         cat:=tab(many(&letters))
  798.         writ("cat=",cat)
  799.         if match("("||cat||",",previous) then {
  800.           while move(-1) do if current[&pos]=="," then break
  801.           move(1)
  802.           pc:=&pos
  803.           tab(upto(',)'))
  804.           return current[1:pc] || previous || current[&pos:0]
  805.         }
  806.         &pos := pc-1
  807.         if current[&pos]~=="," then next else break
  808.       }
  809.     }
  810.   }
  811.   writ("grableft failed for current=", current)
  812. end
  813.  
  814. procedure grabright(opt,headpos,current,nextitem,buildcat)
  815.   local newcurrent
  816.   writ("grabbing right")
  817.   if find("?"|opt,nextitem) then {
  818.     writ("right is blocked"); fail
  819.   }
  820.   current ? if move(headpos) then {
  821.     if tab(upto('?'++opt)) then {
  822.       move(1)
  823.       repeat {
  824.         cat:=tab(many(&letters))
  825.         writ("right-cat=",cat)
  826.         if match("("||cat||",",nextitem) then {
  827.           while move(-1) do if current[&pos]=="," then break
  828.           move(1)
  829.           pc:=&pos
  830.           tab(upto(',)'))
  831.           return current[1:pc] || nextitem || current[&pos:0]
  832.         }
  833.         tab(any('?'++opt)) | break
  834.       }
  835.     }
  836.   }
  837.   if (buildcat=="") & (find("bar",nextitem)=3) &
  838.     (current[3:6]~=="bar") then {
  839.     writ("PREF-Handling:")
  840.     xbar := nextitem[1:7]
  841.     writ("xbar=",xbar)
  842.     current ? if newcurrent:=tab(find(xbar)) then {
  843.       writ("nc/&p=",&pos,newcurrent)
  844.       newcurrent ||:= xbar || tab(bal(')')) || "," ||
  845.         nextitem[7:0] || tab(0)
  846.       writ(1,"newpref=",newcurrent)
  847.       return newcurrent
  848.     }
  849.   }
  850.   writ("grabright failed for current= ", current)
  851. end
  852.  
  853. procedure grab(buildcat)
  854. ## "" = all cats, "NP,PP," specified mothers only
  855. local current, previous, i, head, headpos, nextitem, opt, st1, sublst
  856.   st := trim(st,',') || ","
  857.   sublst := []
  858.   st1 := ""
  859.   opt := "%"
  860.   writ("GRAB(",buildcat,"):")
  861.   writ("st=",st)
  862.   st ? {
  863.     &pos := 5
  864.     while (current := tab(bal(','))) do {
  865.       move(1)
  866.       put(sublst, current)
  867.     }
  868.   }
  869.   writ("*sublst=", *sublst)
  870.   if *sublst=1 then {
  871.     if *bstack>0 then return 99 else return 1
  872.   }
  873.   i := *sublst+1
  874.   if buildcat == "" then opt := ""
  875.   repeat {
  876.     i -:= 1
  877.     #writ("i/sublst=",i)
  878.     #every writes(!sublst,"  ")
  879.     #writ("")
  880.     if i < 1 then break
  881.     current := (sublst[i] | "")
  882.     if *current < 4 then next
  883.     (find(current[2:find(",",current)]||",",buildcat) | (*buildcat<=1)) | next
  884.     (headpos := grab_headpos(current)) | next
  885.     pp := i
  886.     previous := "***"
  887.     until (*previous>4) | (pp<=1) do previous := sublst[pp-:=1]
  888.     writ("previous=", previous)
  889.     writ("current=", current)
  890.     if current := grableft(opt,headpos,current,previous) then {
  891.       sublst[pp] := "*"
  892.       sublst[i] := current
  893.       i +:= 3
  894.       next
  895.     }
  896.     nextitem := "***"
  897.     pn := i
  898.     until (*nextitem>4) | (pn>=*sublst) do nextitem := sublst[pn+:=1]
  899.     writ("current=", current)
  900.     writ(1,"nextitem=", nextitem)
  901.     ## poss. ECM exception I want him...to do it
  902.     if find(",VP",buildcat) & match("(VP,",current) &
  903.       find("?NP?IP",current) then next
  904.     if current := grabright(opt,headpos,current,nextitem,buildcat) then {
  905.       sublst[pn] := "*"
  906.       sublst[i] := current
  907.       i +:= 3
  908.       next
  909.     }
  910.   }
  911.   st1 := "xxx,"
  912.   count := 0
  913.   every i := 1 to *sublst do {
  914.     if sublst[i] ~== "*" then {
  915.       st1 ||:= sublst[i] || ","
  916.       count +:= 1
  917.     }
  918.   }
  919.   writ(1,"new st=",st1)
  920.   if st==st1 then writ("**st unchanged") else {
  921.     st := st1
  922.     showtree(st,"Grabbed: ["||buildcat||"]")
  923.   }
  924.   if *bstack>0 then count:=99
  925.   writ("GRAB(",buildcat,") returns ", count)
  926.   return count
  927. end  # grab
  928.  
  929. procedure xchg(s1,s2,s3)
  930. local result, i
  931.   result := ""
  932.   i := *s2
  933.   s1 ? {
  934.     while result ||:= tab(find(s2)) do {
  935.       result ||:= s3
  936.       move(i)
  937.     }
  938.     return result || tab(0)
  939.   }
  940. end
  941.  
  942. procedure showtree(L, message, x)
  943.   if steps=0 then if *message>0 then fail
  944.   mlist := []
  945.   write(out,L)
  946.   L:="(" || L || ")"
  947.   Lines := []; inter := []
  948.   every 1 to max do {
  949.     put(Lines,""); put(inter,"")
  950.   }
  951.   message := left(trim(message,":"),79)
  952.   gotoXY(5,2*max)
  953.   qwrite(5,2*max,message,normattr)
  954.   handlelist(L,1)
  955.   postproc()
  956.   show()
  957.   write(out,message,repl("\n",2))
  958. end
  959.  
  960. procedure show()
  961. local screenst,xf
  962.   screenst := ""
  963.   every i:=2 to max do {
  964.     screenst ||:= left(map(Lines[i],".ⁿ·√","  .,"),80)
  965.     screenst ||:= left(map(inter[i],"ⁿ.","  "), 80)
  966.     write(out,map(Lines[i],".ⁿ·√","  .,"))
  967.     write(out,map(inter[i],"ⁿ.","  "))
  968.   }
  969.   attr := char(normattr)
  970.   st1 := repl(attr,*screenst)
  971.   #while xattr := get(mlist) do {
  972.   #  xpos := get(mlist)
  973.   #  every i := xpos to xpos+(get(mlist)-1) do
  974.   #    st1[i] := xattr
  975.   #}
  976.   #xattr := char(78)||char(14)||char(6)||char(120)
  977.   #st1 := map(st1,"!$~^",xattr)
  978.   screenst := collate(screenst, st1)
  979.   Poke([47104,0],screenst)
  980.   screenst:=&null; st1 := &null
  981.   if steps=2 then fail
  982.   ch := getch()
  983.   if ch=="q" then stop() else
  984.   # s = secret TreeCad interface:
  985.   if ch=="s" then {
  986.     xf := open("treecad.in","a")
  987.     write(xf,st[5:0])
  988.     close(xf)
  989.   }
  990. end   # show
  991.  
  992.  
  993. procedure get_terms(tree)
  994. local st, x
  995.   st:=""
  996.   tree ? if tab(bal(',)')+1) then {
  997.     while x := tab(bal(',)')) do {
  998.       if x[1] ~== "(" then st ||:= x || "_"
  999.         else st ||:= get_terms(x[2:-1]||",")
  1000.       move(1)
  1001.     }
  1002.   }
  1003.   return st
  1004. end
  1005.  
  1006. procedure handlelist(tree,n)
  1007. local ccol, clen, cattr, xcol,xlen,xattr
  1008.   tree ? if move(1) then {
  1009.     (cat := tab(upto(','))) | { write("empty list:",tree[&pos:0])
  1010.       read(); stop()}
  1011.     catlen := 4
  1012.     if any('$!~^',cat) then {
  1013.       cattr := cat[1]
  1014.       cat[1] := ""
  1015.     } else cattr := ""
  1016.     clen := *cat
  1017.     if *cat<catlen then cat:=center(cat,catlen,"ⁿ") else catlen:=*cat
  1018.     repeat {
  1019.       move(1)
  1020.       (x:=tab(bal(',)'))) | break
  1021.       if (n>=(max-1)) & (x[1]=="(") then x:=get_terms(x[2:-1]||",")
  1022.       if x[1]~=="(" then {
  1023.         x:=trim(x,"_")
  1024.         if any('$!~^',x) then {
  1025.           xattr := x[1]
  1026.           x[1] := ""
  1027.         } else xattr := ""
  1028.         xlen := *x
  1029.         if *x<catlen then x:=center(x,catlen,"ⁿ")
  1030.         if *Lines[max]>*Lines[n+1] then {
  1031.           Lines[n+1]:=left(Lines[n+1], *Lines[max], ".")
  1032.           inter[n+1]:=left(inter[n+1], *Lines[max], ".")
  1033.         }
  1034.         a := "." || center("│",*x,"ⁿ") || "."
  1035.         Lines[n+1] ||:= a
  1036.         inter[n+1] ||:= a
  1037.         every i := n+2 to max-1 do {
  1038.           Lines[i] := left(Lines[i], *Lines[n+1]- (*x+2)) || a
  1039.           inter[i]:= left(inter[i], *Lines[n+1]- (*x+2),".") || a
  1040.         }
  1041.         Lines[max] := left(Lines[max], *Lines[n+1]- (*x+2)) || "." || x || "."
  1042.         xcol := *Lines[max]-(*x+1)
  1043.         Lines[max] ? if move(xcol) then {
  1044.           tab(many('.ⁿ'))
  1045.           xcol := &pos
  1046.         }
  1047.         if *xattr>0 then {
  1048.           put(mlist,xattr)
  1049.           put(mlist,(max-2)*160+xcol)
  1050.           put(mlist,xlen)
  1051.           xattr := ""
  1052.         }
  1053.         inter[max] := left(".", *Lines[max])
  1054.         #show("item")
  1055.       } else handlelist(x, n+1)
  1056.     }
  1057.     Lines[n+1] ? if move(*Lines[n]) then {
  1058.       x:=tab(upto(~'.'))
  1059.       Lines[n]||:= x; inter[n]||:=x
  1060.     }
  1061.     len:=*Lines[n]
  1062.     x:= center("-", *trim(Lines[n+1],".")-len,"-")
  1063.     Lines[n+1][len+1:0] ? while tab(a:=upto(~'.')) do {
  1064.         if x[a]==("-") then {
  1065.           tab(b:=many(~'.'))
  1066.           b-:=1
  1067.           mid :=a+integer((b-a)/2)
  1068.           x[mid]:="!"
  1069.         } else tab(b:=many(~'.'))
  1070.       }
  1071.     x:="." || x || "."
  1072.     while a:=find(".-", x) do x[a+1]:="."
  1073.     while a:=find("-.", x) do x[a]:="."
  1074.     x:= x[2:-1]
  1075.     inter[n]||:=x
  1076.     (L:=find("!", x)) | (L:=10)
  1077.     (R:=find("!.", x||".")) | (R:=10)
  1078.     vor := left(".", L-1,".")
  1079.     insert := center(cat,R-L+1,".")
  1080.     if (R-L)>=*cat then {  # range of items
  1081.       a:=upto(~'.',insert)-1
  1082.       mid := len  + *vor + a+ integer((*cat+1)/2)
  1083.       ccol := *Lines[n] + *vor
  1084.       Lines[n] ||:= vor || insert
  1085.       Lines[n] := left(Lines[n], *inter[n],".")
  1086.       Lines[n] ? if move(ccol) then {
  1087.         tab(many('.ⁿ'))
  1088.         ccol := &pos
  1089.       }
  1090.       if inter[n][mid]=="-" then inter[n][mid]:="t"
  1091.         else inter[n][mid]:="+"
  1092.       #show("RL-item")
  1093.     } else {  # single item
  1094.         if integer(*cat/2*2)=*cat then cat:="."||cat
  1095.         #show("embedded list")
  1096.         if inter[n][-1]~=="." then {
  1097.           Lines[n]:=left(Lines[n],*inter[n]-(integer(*cat/2)+1),".")
  1098.           ccol := *Lines[n]
  1099.           Lines[n] ||:= cat
  1100.           Lines[n] ? if move(ccol) then {
  1101.             tab(many('.ⁿ'))
  1102.             ccol := &pos
  1103.           }
  1104.         } else {
  1105.             a:=*trim(Lines[n+1],".")-len
  1106.             ccol := *Lines[n] + (a - *cat)/2
  1107.             Lines[n] ||:= center(cat, a,".")
  1108.             Lines[n] ? if move(ccol) then {
  1109.               tab(many('.ⁿ'))
  1110.               ccol := &pos
  1111.             }
  1112.             #show("single item")
  1113.         }
  1114.     } # if else
  1115.     if *cattr>0 then {
  1116.       put(mlist,cattr)
  1117.       put(mlist,(n-2)*160+ccol)
  1118.       put(mlist,clen)
  1119.       cattr := ""
  1120.     }
  1121.   } #treescan
  1122. end
  1123.  
  1124.  
  1125. procedure postproc()
  1126. static rep1, rep2
  1127.   initial {
  1128.     rep1:=[".!.",".!", "-!.", "-!-", "t!", "!t",".+."]
  1129.     rep2:=[".i.",".L", "-R.", "-T-", "tT", "Tt",".!."]
  1130.   }
  1131.   every i:= 2 to max do {
  1132.     inter[i-1] := replace(inter[i-1]||".",rep1,rep2)
  1133.     inter[i-1] := map(inter[i-1],"i!LRTt+-.","││┌┐┬┴┼─ ")
  1134.   }
  1135. end #postproc
  1136.  
  1137. procedure replace(subject, rep1, rep2)
  1138.   every i:= 1 to *rep1 do subject := xchg(subject,rep1[i],rep2[i])
  1139.   return subject
  1140. end
  1141.  
  1142. procedure collate(s1,s2)
  1143. # ex Icon Prog Lib
  1144.    local length, ltemp, rtemp
  1145.    static llabels, rlabels, clabels, blabels, half
  1146.    initial {
  1147.       llabels := "ab"
  1148.       rlabels := "cd"
  1149.       blabels := llabels || rlabels
  1150.       clabels := "acbd"
  1151.       half := 2
  1152.       ltemp := left(&cset,*&cset / 2)
  1153.       rtemp := right(&cset,*&cset / 2)
  1154.       clabels := collate(ltemp,rtemp)
  1155.       llabels := ltemp
  1156.       rlabels := rtemp
  1157.       blabels := string(&cset)
  1158.       half := *llabels
  1159.       }
  1160.    length := *s1
  1161.    if length <= half then
  1162.       return map(left(clabels,2 * length),left(llabels,length) ||
  1163.          left(rlabels,length),s1 || s2)
  1164.    else return map(clabels,blabels,left(s1,half) || left(s2,half)) ||
  1165.       collate(right(s1,length - half),right(s2,length - half))
  1166. end
  1167.  
  1168.  
  1169. #### VIDEO ROUTINES ########
  1170.  
  1171. procedure clrscr(attr)
  1172.   Poke([47104, 0], repl(" "||char(attr), 4000))
  1173. end
  1174.  
  1175. procedure qwrite(x, y, s1, attr)
  1176.   s1 := collate(s1, repl(char(attr), *s1))
  1177.   offset := 2*((y-1)*80 + (x - 1))
  1178.   Poke([47104,offset],s1)
  1179. end
  1180.  
  1181. procedure gotoXY(X, Y)
  1182. local dx
  1183.   X -:= 1;  Y-:=1  # 0,0 = upper left for int 10
  1184.   dx := Y * 256 + X
  1185.   Int86([16,512,0,0,dx,0,0,0,0])
  1186. end
  1187.  
  1188.  
  1189.  
  1190.